home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / Xstring.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-13  |  16.4 KB  |  610 lines
  1.  
  2. #pragma segment Xstring
  3.  
  4. /* 
  5.  * string.c --
  6.  *
  7.  *      Extended TCL string and character manipulation commands.
  8.  *---------------------------------------------------------------------------
  9.  * Copyright 1991 Karl Lehenbauer and Mark Diekhans.
  10.  *
  11.  * Permission to use, copy, modif-, and distribute this software and its
  12.  * documentation for any purpose and without fee is hereby granted, provided
  13.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14.  * Mark Diekhans make no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without express or
  16.  * implied warranty.
  17.  */
  18.  
  19. #include "tcl.h"
  20.  
  21. #define STREQU(A, B)    ( strcmp ( (A) , (B) ) == 0 )
  22.  
  23. #ifndef isascii
  24. #define isascii(c) (1)
  25. #endif
  26.  
  27. extern int free();
  28. /*
  29.  * Prototypes of internal functions.
  30.  */
  31. unsigned int
  32. ExpandString _ANSI_ARGS_((unsigned char *s,
  33.                           unsigned char  buf[]));
  34.  
  35.  
  36. /*
  37.  *----------------------------------------------------------------------
  38.  *
  39.  * Tcl_CindexCmd --
  40.  *     Implements the cindex TCL command:
  41.  *         cindex string index
  42.  *
  43.  * Results:
  44.  *      Returns the character indexed by  index  (zero  based)  from
  45.  *      string. 
  46.  *
  47.  *----------------------------------------------------------------------
  48.  */
  49. int
  50. Tcl_CindexCmd (clientData, interp, argc, argv)
  51.     ClientData   clientData;
  52.     Tcl_Interp  *interp;
  53.     int          argc;
  54.     char       **argv;
  55. {
  56.     unsigned index;
  57.  
  58.     if (argc != 3) {
  59.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], " string index",
  60.                           (char *) NULL);
  61.         return TCL_ERROR;
  62.     }
  63.  
  64.     if (Tcl_GetUnsigned (interp, argv[2], &index) != TCL_OK)
  65.         return TCL_ERROR;
  66.     if (index >= strlen (argv [1]))
  67.         return TCL_OK;
  68.  
  69.     interp->result [0] = argv[1][index];
  70.     interp->result [1] = 0;
  71.     return TCL_OK;
  72.  
  73. } /* Tcl_CindexCmd */
  74.  
  75. /*
  76.  *----------------------------------------------------------------------
  77.  *
  78.  * Tcl_ClengthCmd --
  79.  *     Implements the clength TCL command:
  80.  *         clength string
  81.  *
  82.  * Results:
  83.  *      Returns the length of string in characters. 
  84.  *
  85.  *----------------------------------------------------------------------
  86.  */
  87. int
  88. Tcl_ClengthCmd (clientData, interp, argc, argv)
  89.     ClientData   clientData;
  90.     Tcl_Interp  *interp;
  91.     int          argc;
  92.     char       **argv;
  93. {
  94.  
  95.     if (argc != 2) {
  96.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], " string", 
  97.                           (char *) NULL);
  98.         return TCL_ERROR;
  99.     }
  100.  
  101.     sprintf (interp->result, "%d", strlen (argv[1]));
  102.     return TCL_OK;
  103.  
  104. } /* Tcl_ClengthCmd */
  105.  
  106. /*
  107.  *----------------------------------------------------------------------
  108.  *
  109.  * Tcl_CrangeCmd --
  110.  *     Implements the crange and csubstr TCL commands:
  111.  *         crange string first last
  112.  *         csubstr string first length
  113.  *
  114.  * Results:
  115.  *      Standard Tcl result.
  116.  *----------------------------------------------------------------------
  117.  */
  118. int
  119. Tcl_CrangeCmd (clientData, interp, argc, argv)
  120.     ClientData   clientData;
  121.     Tcl_Interp  *interp;
  122.     int          argc;
  123.     char       **argv;
  124. {
  125.     unsigned  fullLen, first;
  126.     unsigned  subLen;
  127.     char     *strPtr;
  128.     char      holdChar;
  129.     int       isRange = (argv [0][1] == 'r');  /* csubstr or crange */
  130.  
  131.     if (argc != 4) {
  132.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  133.                           " string first ", 
  134.                           (isRange) ? "last" : "length",
  135.                           (char *) NULL);
  136.         return TCL_ERROR;
  137.     }
  138.  
  139.     if (Tcl_GetUnsigned (interp, argv[2], &first) != TCL_OK)
  140.         return TCL_ERROR;
  141.  
  142.     fullLen = strlen (argv [1]);
  143.     if (first >= fullLen)
  144.         return TCL_OK;
  145.  
  146.     if (STREQU (argv[3], "end"))
  147.         subLen = fullLen - first;
  148.     else {
  149.         if (Tcl_GetUnsigned (interp, argv[3], &subLen) != TCL_OK)
  150.             return TCL_ERROR;
  151.         
  152.         if (isRange) {
  153.             if (subLen < first) {
  154.                 Tcl_AppendResult (interp, "last is before first",
  155.                                   (char *) NULL);
  156.                 return TCL_ERROR;
  157.             }
  158.             subLen = subLen - first +1;
  159.         }
  160.  
  161.         if (first + subLen > fullLen)
  162.             subLen = fullLen - first;
  163.     }
  164.  
  165.     strPtr = argv [1] + first;
  166.  
  167.     holdChar = strPtr [subLen];
  168.     strPtr [subLen] = '\0';
  169.     Tcl_SetResult (interp, strPtr, TCL_VOLATILE);
  170.     strPtr [subLen] = holdChar;
  171.  
  172.     return TCL_OK;
  173.  
  174. } /* Tcl_CrangeCmd */
  175.  
  176. /*
  177.  *----------------------------------------------------------------------
  178.  *
  179.  * Tcl_ReplicateCmd --
  180.  *     Implements the replicate TCL command:
  181.  *         replicate string count
  182.  *     See the string(TCL) manual page.
  183.  *
  184.  * Results:
  185.  *      Returns string replicated count times.
  186.  *
  187.  *----------------------------------------------------------------------
  188.  */
  189. int
  190. Tcl_ReplicateCmd (clientData, interp, argc, argv)
  191.     ClientData   clientData;
  192.     Tcl_Interp  *interp;
  193.     int          argc;
  194.     char       **argv;
  195. {
  196.     unsigned       repCount;
  197.     register char *srcPtr, *scanPtr, *newPtr;
  198.     register int   newLen, cnt;
  199.  
  200.     if (argc != 3) {
  201.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  202.                           " string count", (char *) NULL);
  203.         return TCL_ERROR;
  204.     }
  205.  
  206.     if (Tcl_GetUnsigned (interp, argv[2], &repCount) != TCL_OK)
  207.         return TCL_ERROR;
  208.  
  209.     srcPtr = argv [1];
  210.     newLen = strlen (srcPtr) * repCount;
  211.     if (newLen >= TCL_RESULT_SIZE)
  212.         Tcl_SetResult (interp, ckalloc ((unsigned) newLen + 1), TCL_DYNAMIC);
  213.  
  214.     newPtr = interp->result;
  215.     for (cnt = 0; cnt < repCount; cnt++) {
  216.         for (scanPtr = srcPtr ; *scanPtr != 0 ; )
  217.             *newPtr++ = *scanPtr++;
  218.         }
  219.     *newPtr = 0;
  220.  
  221.     return TCL_OK;
  222.  
  223. } /* Tcl_seplicateCmd */
  224.  
  225. /*
  226.  *----------------------------------------------------------------------
  227.  *
  228.  * ExpandString --
  229.  *  Build an expand version of a translit range specification.
  230.  *
  231.  * Results:
  232.  *  TRUE it the expansion is ok, FALSE it its too long.
  233.  *
  234.  *----------------------------------------------------------------------
  235.  */
  236. #define MAX_EXPANSION 255
  237.  
  238. static unsigned int
  239. ExpandString (s, buf)
  240.     unsigned char *s;
  241.     unsigned char  buf[];
  242. {
  243.     int i, j;
  244.  
  245.     i = 0;
  246.     while((*s !=0) && i < MAX_EXPANSION) {
  247.         if(s[1] == '-' && s[2] > s[0]) {
  248.             for(j = s[0]; j <= s[2]; j++)
  249.                 buf[i++] = j;
  250.             s += 3;
  251.         } else
  252.             buf[i++] = *s++;
  253.     }
  254.     buf[i] = 0;
  255.     return (i < MAX_EXPANSION);
  256. }
  257.  
  258. /*
  259.  *----------------------------------------------------------------------
  260.  *
  261.  * Tcl_TranslitCmd --
  262.  *     Implements the TCL translit command:
  263.  *     translit inrange outrange string
  264.  *
  265.  * Results:
  266.  *  Standard TCL results.
  267.  *
  268.  *----------------------------------------------------------------------
  269.  */
  270. int
  271. Tcl_TranslitCmd (clientData, interp, argc, argv)
  272.     ClientData  clientData;
  273.     Tcl_Interp *interp;
  274.     int         argc;
  275.     char       **argv;
  276. {
  277.     unsigned char from [MAX_EXPANSION+1];
  278.     unsigned char to   [MAX_EXPANSION+1];
  279.     unsigned char map  [MAX_EXPANSION+1];
  280.     unsigned char *s, *t;
  281.     int i;
  282.  
  283.     if (argc != 4) {
  284.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  285.                           " from to string", (char *) NULL);
  286.         return TCL_ERROR;
  287.     }
  288.  
  289.     if (!ExpandString ((unsigned char *) argv[1], from)) {
  290.         interp->result = "inrange expansion too long";
  291.         return TCL_ERROR;
  292.     }
  293.  
  294.     if (!ExpandString ((unsigned char *) argv[2], to)) {
  295.         interp->result = "outrange expansion too long";
  296.         return TCL_ERROR;
  297.     }
  298.  
  299.     for(i = 0; i <= MAX_EXPANSION ; i++)
  300.         map[i] = i;
  301.  
  302.     for(i = 0; to[i] != 0; i++)
  303.         if(from[i])
  304.             map[from[i]] = to[i];
  305.         else
  306.             break;
  307.     if(to[i] != 0) {
  308.         interp->result = "inrange longer than outrange";
  309.         return TCL_ERROR;
  310.     }
  311.  
  312.     for(; from[i]; i++)
  313.         map[from[i]] = 0;
  314.  
  315.     for (s = t = (unsigned char *)argv[3]; *s; s++) {
  316.         if(map[*s])
  317.             *t++ = map[*s];
  318.     }
  319.     *t = 0;
  320.  
  321.     Tcl_SetResult (interp, argv[3], TCL_VOLATILE);
  322.  
  323.     return TCL_OK;
  324. }
  325.  
  326. /*
  327.  *----------------------------------------------------------------------
  328.  *
  329.  * Tcl_CtypeCmd --
  330.  *
  331.  *      This function implements the 'ctype' command:
  332.  *      ctype class string
  333.  *
  334.  *      Where class is one of the following:
  335.  *        digit, xdigit, lower, upper, alpha, alnum,
  336.  *        space, cntrl,  punct, print, graph, ascii, char or ord.
  337.  *
  338.  * Results:
  339.  *       One or zero: Depending if all the characters in the string are of
  340.  *       the desired class.  Char and ord provide conversions and return the
  341.  *       converted value.
  342.  *
  343.  *----------------------------------------------------------------------
  344.  */
  345. int
  346. Tcl_CtypeCmd (clientData, interp, argc, argv)
  347.     ClientData   clientData;
  348.     Tcl_Interp  *interp;
  349.     int          argc;
  350.     char       **argv;
  351. {
  352.     register char *_class;
  353.     register char *scanPtr;
  354.  
  355.     if (argc != 3) {
  356.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], " class string",
  357.                           (char *) NULL);
  358.         return TCL_ERROR;
  359.     }
  360.  
  361.     _class = argv [1];
  362.  
  363.     /*
  364.      * Handle conversion requests.
  365.      */
  366.     if (STREQU (_class, "char")) {
  367.         int number;
  368.  
  369.         if (Tcl_GetInt (interp, argv [2], &number) != TCL_OK)
  370.             return TCL_ERROR;
  371.         if ((number < 0) || (number > 255)) {
  372.             Tcl_AppendResult (interp, "number must be in the range 0..255",
  373.                               (char *) NULL);
  374.             return TCL_ERROR;
  375.         }
  376.  
  377.         interp->result [0] = number;
  378.         interp->result [1] = 0;
  379.         return TCL_OK;
  380.     }
  381.  
  382.     if (STREQU (_class, "ord")) {
  383.         if (strlen (argv [2]) != 1) {
  384.             Tcl_AppendResult (interp, "string to convert must be only one",
  385.                               " character", (char *) NULL);
  386.             return TCL_ERROR;
  387.         }
  388.  
  389.         sprintf(interp->result, "%d", (int)(*argv[2]));
  390.         return TCL_OK;
  391.     }
  392.  
  393.     /*
  394.      * Select based on the first letter of the 'class' argument to chose the 
  395.      * macro to test characters with.  In some cases another character must be
  396.      * switched on to determine which macro to use.  This is gross, but better
  397.      * we only have to do a string compare once to test if class is correct.
  398.      */
  399.     if ((_class [2] == 'n') && STREQU (_class, "alnum")) {
  400.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  401.             if (!isalnum (*scanPtr))
  402.                 break;
  403.         }
  404.         goto returnResult;
  405.     }
  406.     if ((_class [2] == 'p') && STREQU (_class, "alpha")) {
  407.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  408.             if (! isalpha (*scanPtr))
  409.                 break;
  410.         }
  411.         goto returnResult;
  412.     }
  413.     if ((_class [1] == 's') && STREQU (_class, "ascii")) {
  414.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  415.             if (!isascii (*scanPtr))
  416.                 break;
  417.         }
  418.         goto returnResult;
  419.     }
  420.     if (STREQU (_class, "cntrl")) {
  421.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  422.             if (!iscntrl (*scanPtr))
  423.                 break;
  424.         }
  425.         goto returnResult;
  426.     }
  427.     if (STREQU (_class, "digit")) {
  428.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  429.             if (!isdigit (*scanPtr))
  430.                 break;
  431.         }
  432.         goto returnResult;
  433.     }
  434.     if (STREQU (_class, "graph")) {
  435.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  436.             if (!isgraph (*scanPtr))
  437.                 break;
  438.         }
  439.         goto returnResult;
  440.     }
  441.     if (STREQU (_class, "lower")) {
  442.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  443.             if (!islower (*scanPtr))
  444.                 break;
  445.         }
  446.         goto returnResult;
  447.     }
  448.     if (STREQU (_class, "number")) {
  449.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  450.             if ( ! (isdigit (*scanPtr) || *scanPtr == '.'
  451.                     || *scanPtr == 'e' || *scanPtr == 'E'
  452.                     || *scanPtr == '-' || *scanPtr == '+') )
  453.                 break;
  454.         }
  455.         goto returnResult;
  456.     }
  457.     if ((_class [1] == 'r') && STREQU (_class, "print")) {
  458.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  459.             if (!isprint (*scanPtr))
  460.                 break;
  461.         }
  462.         goto returnResult;
  463.     }
  464.     if ((_class [1] == 'u') && STREQU (_class, "punct")) {
  465.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  466.             if (!ispunct (*scanPtr))
  467.                 break;
  468.         }
  469.         goto returnResult;
  470.     }
  471.     if (STREQU (_class, "space")) {
  472.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  473.             if (!isspace (*scanPtr))
  474.                 break;
  475.         }
  476.         goto returnResult;
  477.     }
  478.     if (STREQU (_class, "upper")) {
  479.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  480.             if (!isupper (*scanPtr))
  481.                 break;
  482.         }
  483.         goto returnResult;
  484.     }
  485.     if (STREQU (_class, "xdigit")) {
  486.         for (scanPtr = argv [2]; *scanPtr != 0; scanPtr++) {
  487.             if (!isxdigit (*scanPtr))
  488.                 break;
  489.         }
  490.         goto returnResult;
  491.     }
  492.     /*
  493.      * No match on subcommand.
  494.      */
  495.     Tcl_AppendResult (interp, "unrecognized class specification: \"", _class,
  496.                       "\", expected one of: alnum, alpha, ascii, char, ",
  497.                       "cntrl, digit, graph, lower, number, ord, print, ",
  498.                       "punct, space, upper or xdigit", (char *) NULL);
  499.     return TCL_ERROR;
  500.  
  501.     /*
  502.      * Return true or false, depending if the end was reached.  Alwas return 
  503.      * false for a null string.
  504.      */
  505. returnResult:
  506.     interp->result [0] = (*scanPtr == 0 && scanPtr != argv [2]) ? '1' : '0';
  507.     interp->result [1] = 0;
  508.     return TCL_OK;
  509.  
  510. }
  511.  
  512.  
  513.  
  514. /*
  515.  *----------------------------------------------------------------------
  516.  *
  517.  * Tcl_LoopCmd --
  518.  *     Implements the TCL loop command:
  519.  *         loop var start end [increment] command
  520.  *
  521.  * Results:
  522.  *      Standard TCL results.
  523.  *
  524.  *----------------------------------------------------------------------
  525.  */
  526. int
  527. Tcl_LoopCmd (dummy, interp, argc, argv)
  528.     ClientData  dummy;
  529.     Tcl_Interp *interp;
  530.     int         argc;
  531.     char      **argv;
  532. {
  533.     int   result = TCL_OK;
  534.     long  i, lo, hi, incr = 1;
  535.     char *command;
  536.  
  537.     if ((argc < 5) || (argc > 6)) {
  538.         Tcl_AppendResult (interp, "wrong # args: ", argv [0], 
  539.                           " var lo hi [incr] command", (char *) NULL);
  540.         return TCL_ERROR;
  541.     }
  542.  
  543.     if (Tcl_GetLong (interp, argv[2], &lo) != TCL_OK)
  544.         return TCL_ERROR;
  545.     if (Tcl_GetLong (interp, argv[3], &hi) != TCL_OK)
  546.         return TCL_ERROR;
  547.     if (argc == 5)
  548.         command = argv[4];
  549.     else {
  550.         if (Tcl_GetLong (interp, argv[4], &incr) != TCL_OK)
  551.             return TCL_ERROR;
  552.         command = argv[5];
  553.     }
  554.  
  555.     for (i = lo; (((i < hi) && (incr > 0)) || ((i > hi) && (incr < 0)));
  556.              i += incr) {
  557.         char itxt[12];
  558.  
  559.         sprintf(itxt,"%ld",i);
  560.         if (Tcl_SetVar(interp, argv[1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
  561.             return TCL_ERROR;
  562.  
  563.         result = Tcl_Eval(interp, command, 0, (char **) NULL);
  564.         if (result != TCL_OK) {
  565.             if (result == TCL_CONTINUE) {
  566.                 result = TCL_OK;
  567.             } else if (result == TCL_BREAK) {
  568.                 result = TCL_OK;
  569.                 break;
  570.             } else if (result == TCL_ERROR) {
  571.                 char buf [64];
  572.  
  573.                 sprintf (buf, "\n    (\"loop\" body line %d)", 
  574.                          interp->errorLine);
  575.                 Tcl_AddErrorInfo (interp, buf);
  576.                 break;
  577.             } else {
  578.                 break;
  579.             }
  580.         }
  581.     }
  582.     return result;
  583. }
  584.  
  585.  
  586. Tcl_InitXTND(interp)
  587. Tcl_Interp    *interp;
  588. {
  589.     /*
  590.      * from string.c
  591.      */
  592.     Tcl_CreateCommand(interp, "cindex", Tcl_CindexCmd, 
  593.                      (ClientData)NULL, (void (*)())NULL);
  594.     Tcl_CreateCommand(interp, "clength", Tcl_ClengthCmd, 
  595.                      (ClientData)NULL, (void (*)())NULL);
  596.     Tcl_CreateCommand(interp, "crange", Tcl_CrangeCmd, 
  597.                      (ClientData)NULL, (void (*)())NULL);
  598.     Tcl_CreateCommand(interp, "csubstr", Tcl_CrangeCmd, 
  599.                      (ClientData)NULL, (void (*)())NULL);
  600.     Tcl_CreateCommand(interp, "replicate", Tcl_ReplicateCmd, 
  601.                      (ClientData)NULL, (void (*)())NULL);
  602.     Tcl_CreateCommand (interp, "translit", Tcl_TranslitCmd, (ClientData)NULL,
  603.                       (void (*)())NULL);
  604.     Tcl_CreateCommand (interp, "ctype", Tcl_CtypeCmd,
  605.                        (ClientData)NULL, (void (*)())NULL);
  606.     Tcl_CreateCommand(interp, "loop", Tcl_LoopCmd, 
  607.                      (ClientData)NULL, (void (*)())NULL);
  608.  
  609.     }
  610.